home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 1.iso / ARGONET / PD / PROGRAMMING / PERL.SPK / Perl5001 / !Perl / Lib / ExtUtils / pm / xsubpp < prev   
Encoding:
Text File  |  1996-01-23  |  14.5 KB  |  631 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>] file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =back
  44.  
  45. =head1 ENVIRONMENT
  46.  
  47. No environment variables are used.
  48.  
  49. =head1 AUTHOR
  50.  
  51. Larry Wall
  52.  
  53. =head1 SEE ALSO
  54.  
  55. perl(1)
  56.  
  57. =cut
  58.  
  59. $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
  60. @ARGV !='' or die $usage;
  61.  
  62. SWITCH: while ($ARGV[0] =~ s/^-//) {
  63.     $flag = shift @ARGV;
  64.     $spat = shift,    next SWITCH    if $flag eq 's';
  65.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  66.     $except = 1,    next SWITCH    if $flag eq 'except';
  67.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  68.     die $usage;
  69. }
  70. @ARGV == 1 or die $usage;
  71. #chop($pwd = `pwd`);
  72. # Check for error message from VMS
  73. #if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
  74. ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
  75.     or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
  76.     or ($dir, $filename) = ('.', $ARGV[0]);
  77. #chdir($dir);
  78.  
  79. $typemap = shift @ARGV;
  80. foreach $typemap (@tm) {
  81.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  82. }
  83. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  84.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  85.                 ../typemap typemap);
  86. foreach $typemap (@tm) {
  87.     open(TYPEMAP, $typemap) || next;
  88.     $mode = Typemap;
  89.     $current = \$junk;
  90.     while (<TYPEMAP>) {
  91.     next if /^#/;
  92.     if (/^INPUT\s*$/) { $mode = Input, next }
  93.     if (/^OUTPUT\s*$/) { $mode = Output, next }
  94.     if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
  95.     if ($mode eq Typemap) {
  96.         chop;
  97.         ($typename, $kind) = split(/\t+/, $_, 2);
  98.         $type_kind{$typename} = $kind if $kind ne '';
  99.     }
  100.     elsif ($mode eq Input) {
  101.         if (/^\s/) {
  102.         $$current .= $_;
  103.         }
  104.         else {
  105.         s/\s*$//;
  106.         $input_expr{$_} = '';
  107.         $current = \$input_expr{$_};
  108.         }
  109.     }
  110.     else {
  111.         if (/^\s/) {
  112.         $$current .= $_;
  113.         }
  114.         else {
  115.         s/\s*$//;
  116.         $output_expr{$_} = '';
  117.         $current = \$output_expr{$_};
  118.         }
  119.     }
  120.     }
  121.     close(TYPEMAP);
  122. }
  123.  
  124. foreach $key (keys %input_expr) {
  125.     $input_expr{$key} =~ s/\n+$//;
  126. }
  127.  
  128. sub Q {
  129.     local $text = shift;
  130.     $text =~ tr/#//d;
  131.     $text =~ s/\[\[/{/g;
  132.     $text =~ s/\]\]/}/g;
  133.     $text;
  134. }
  135.  
  136. open(F, $filename) || die "cannot open $filename\n";
  137.  
  138. while (<F>) {
  139.     last if ($Module, $foo, $Package, $foo1, $Prefix) =
  140.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
  141.     print $_;
  142. }
  143. exit 0 if $_ eq "";
  144. $lastline = $_;
  145.  
  146. sub fetch_para {
  147.     # parse paragraph
  148.     @line = ();
  149.     if ($lastline ne "") {
  150.     if ($lastline =~
  151.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  152.         $Module = $1;
  153.         $foo = $2;
  154.         $Package = $3;
  155.         $foo1 = $4;
  156.         $Prefix = $5;
  157.         ($Module_cname = $Module) =~ s/\W/_/g;
  158.         ($Packid = $Package) =~ s/:/_/g;
  159.         $Packprefix = $Package;
  160.         $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
  161.         while (<F>) {
  162.         chop;
  163.         next if /^#/ &&
  164.             !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  165.         last if /^\S/;
  166.         }
  167.         push(@line, $_) if $_ ne "";
  168.     }
  169.     else {
  170.         push(@line, $lastline);
  171.     }
  172.     $lastline = "";
  173.     while (<F>) {
  174.         next if /^#/ &&
  175.         !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  176.         chop;
  177.         if (/^\S/ && @line && $line[-1] eq "") {
  178.         $lastline = $_;
  179.         last;
  180.         }
  181.         else {
  182.         push(@line, $_);
  183.         }
  184.     }
  185.     pop(@line) while @line && $line[-1] =~ /^\s*$/;
  186.     }
  187.     $PPCODE = grep(/PPCODE:/, @line);
  188.     scalar @line;
  189. }
  190.  
  191. while (&fetch_para) {
  192.     # initialize info arrays
  193.     undef(%args_match);
  194.     undef(%var_types);
  195.     undef(%var_addr);
  196.     undef(%defaults);
  197.     undef($class);
  198.     undef($static);
  199.     undef($elipsis);
  200.  
  201.     # extract return type, function name and arguments
  202.     $ret_type = shift(@line);
  203.     if ($ret_type =~ /^BOOT:/) {
  204.         push (@BootCode, @line, "", "") ;
  205.         next ;
  206.     }
  207.     if ($ret_type =~ /^static\s+(.*)$/) {
  208.         $static = 1;
  209.         $ret_type = $1;
  210.     }
  211.     $func_header = shift(@line);
  212.     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
  213.     if ($func_name =~ /(.*)::(.*)/) {
  214.         $class = $1;
  215.         $func_name = $2;
  216.     }
  217.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  218.     push(@Func_name, "${Packid}_$func_name");
  219.     push(@Func_pname, $pname);
  220.     @args = split(/\s*,\s*/, $orig_args);
  221.     if (defined($class)) {
  222.     if (defined($static)) {
  223.         unshift(@args, "CLASS");
  224.         $orig_args = "CLASS, $orig_args";
  225.         $orig_args =~ s/^CLASS, $/CLASS/;
  226.     }
  227.     else {
  228.         unshift(@args, "THIS");
  229.         $orig_args = "THIS, $orig_args";
  230.         $orig_args =~ s/^THIS, $/THIS/;
  231.     }
  232.     }
  233.     $orig_args =~ s/"/\\"/g;
  234.     $min_args = $num_args = @args;
  235.     foreach $i (0..$num_args-1) {
  236.         if ($args[$i] =~ s/\.\.\.//) {
  237.             $elipsis = 1;
  238.             $min_args--;
  239.             if ($args[i] eq '' && $i == $num_args - 1) {
  240.             pop(@args);
  241.             last;
  242.             }
  243.         }
  244.         if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
  245.             $min_args--;
  246.             $args[$i] = $1;
  247.             $defaults{$args[$i]} = $2;
  248.             $defaults{$args[$i]} =~ s/"/\\"/g;
  249.         }
  250.     }
  251.     if (defined($class)) {
  252.         $func_args = join(", ", @args[1..$#args]);
  253.     } else {
  254.         $func_args = join(", ", @args);
  255.     }
  256.     @args_match{@args} = 1..@args;
  257.  
  258.     # print function header
  259.     print Q<<"EOF";
  260. #XS(XS_${Packid}_$func_name)
  261. #[[
  262. #    dXSARGS;
  263. EOF
  264.     if ($elipsis) {
  265.     $cond = qq(items < $min_args);
  266.     }
  267.     elsif ($min_args == $num_args) {
  268.     $cond = qq(items != $min_args);
  269.     }
  270.     else {
  271.     $cond = qq(items < $min_args || items > $num_args);
  272.     }
  273.  
  274.     print Q<<"EOF" if $except;
  275. #    char errbuf[1024];
  276. #    *errbuf = '\0';
  277. EOF
  278.  
  279.     print Q<<"EOF";
  280. #    if ($cond) {
  281. #    croak("Usage: $pname($orig_args)");
  282. #    }
  283. EOF
  284.  
  285.     print Q<<"EOF" if $PPCODE;
  286. #    SP -= items;
  287. EOF
  288.  
  289.     # Now do a block of some sort.
  290.  
  291.     $condnum = 0;
  292.     if (!@line) {
  293.     @line = "CLEANUP:";
  294.     }
  295.     while (@line) {
  296.     if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
  297.         $cond = shift(@line);
  298.         if ($condnum == 0) {
  299.         print "    if ($cond)\n";
  300.         }
  301.         elsif ($cond ne '') {
  302.         print "    else if ($cond)\n";
  303.         }
  304.         else {
  305.         print "    else\n";
  306.         }
  307.         $condnum++;
  308.     }
  309.  
  310.     if ($except) {
  311.         print Q<<"EOF";
  312. #    TRY [[
  313. EOF
  314.     }
  315.     else {
  316.         print Q<<"EOF";
  317. #    [[
  318. EOF
  319.     }
  320.  
  321.     # do initialization of input variables
  322.     $thisdone = 0;
  323.     $retvaldone = 0;
  324.     $deferred = "";
  325.     while (@line) {
  326.         $_ = shift(@line);
  327.         last if /^\s*NOT_IMPLEMENTED_YET/;
  328.         last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
  329.         ($var_type, $var_name, $var_init) =
  330.             /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
  331.         # Catch common errors. More error checking required here.
  332.         blurt("Error: no tab in $pname argument declaration '$_'\n")
  333.             unless (m/\S+\s*\t\s*\S+/);
  334.         # catch C style argument declaration (this could be made alowable syntax)
  335.         warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
  336.             if ($var_name =~ s/;//g); # eg SV *<tab>name;
  337.         # catch many errors similar to: SV<tab>* name
  338.         blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
  339.             unless ($var_name =~ m/^&?\w+$/);
  340.         if ($var_name =~ /^&/) {
  341.             $var_name =~ s/^&//;
  342.             $var_addr{$var_name} = 1;
  343.         }
  344.         $thisdone |= $var_name eq "THIS";
  345.         $retvaldone |= $var_name eq "RETVAL";
  346.         $var_types{$var_name} = $var_type;
  347.         print "\t" . &map_type($var_type);
  348.         $var_num = $args_match{$var_name};
  349.         if ($var_addr{$var_name}) {
  350.             $func_args =~ s/\b($var_name)\b/&\1/;
  351.         }
  352.         if ($var_init !~ /^=\s*NO_INIT\s*$/) {
  353.             if ($var_init !~ /^\s*$/) {
  354.                 &output_init($var_type, $var_num,
  355.                     "$var_name $var_init");
  356.             } elsif ($var_num) {
  357.                 # generate initialization code
  358.                 &generate_init($var_type, $var_num, $var_name);
  359.             } else {
  360.                 print ";\n";
  361.             }
  362.         } else {
  363.             print "\t$var_name;\n";
  364.         }
  365.     }
  366.     if (!$thisdone && defined($class)) {
  367.         if (defined($static)) {
  368.         print "\tchar *";
  369.         $var_types{"CLASS"} = "char *";
  370.         &generate_init("char *", 1, "CLASS");
  371.         }
  372.         else {
  373.         print "\t$class *";
  374.         $var_types{"THIS"} = "$class *";
  375.         &generate_init("$class *", 1, "THIS");
  376.         }
  377.     }
  378.  
  379.     # do code
  380.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  381.         print "\ncroak(\"$pname: not implemented yet\");\n";
  382.     } else {
  383.         if ($ret_type ne "void") {
  384.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  385.                 if !$retvaldone;
  386.             $args_match{"RETVAL"} = 0;
  387.             $var_types{"RETVAL"} = $ret_type;
  388.         }
  389.         if (/^\s*PPCODE:/) {
  390.             print $deferred;
  391.             while (@line) {
  392.                 $_ = shift(@line);
  393.                 die "PPCODE must be last thing"
  394.                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  395.                 print "$_\n";
  396.             }
  397.             print "\tPUTBACK;\n\treturn;\n";
  398.         } elsif (/^\s*CODE:/) {
  399.             print $deferred;
  400.             while (@line) {
  401.                 $_ = shift(@line);
  402.                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  403.                 print "$_\n";
  404.             }
  405.         } elsif ($func_name eq "DESTROY") {
  406.             print $deferred;
  407.             print "\n\t";
  408.             print "delete THIS;\n"
  409.         } else {
  410.             print $deferred;
  411.             print "\n\t";
  412.             if ($ret_type ne "void") {
  413.                 print "RETVAL = ";
  414.             }
  415.             if (defined($static)) {
  416.                 if ($func_name =~ /^new/) {
  417.                 $func_name = "$class";
  418.                 }
  419.                 else {
  420.                 print "$class::";
  421.                 }
  422.             } elsif (defined($class)) {
  423.                 print "THIS->";
  424.             }
  425.             if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
  426.                 $func_name = $2;
  427.             }
  428.             print "$func_name($func_args);\n";
  429.             &generate_output($ret_type, 0, "RETVAL")
  430.                 unless $ret_type eq "void";
  431.         }
  432.     }
  433.  
  434.     # do output variables
  435.     if (/^\s*OUTPUT\s*:/) {
  436.         while (@line) {
  437.             $_ = shift(@line);
  438.             last if /^\s*CLEANUP\s*:/;
  439.             s/^\s+//;
  440.             ($outarg, $outcode) = split(/\t+/);
  441.             if ($outcode) {
  442.                 print "\t$outcode\n";
  443.             } else {
  444.                 die "$outarg not an argument"
  445.                     unless defined($args_match{$outarg});
  446.                 $var_num = $args_match{$outarg};
  447.                 &generate_output($var_types{$outarg}, $var_num,
  448.                     $outarg); 
  449.             }
  450.         }
  451.     }
  452.     # do cleanup
  453.     if (/^\s*CLEANUP\s*:/) {
  454.         while (@line) {
  455.             $_ = shift(@line);
  456.             last if /^\s*CASE\s*:/;
  457.             print "$_\n";
  458.         }
  459.     }
  460.     # print function trailer
  461.     if ($except) {
  462.         print Q<<EOF;
  463. #    ]]
  464. #    BEGHANDLERS
  465. #    CATCHALL
  466. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  467. #    ENDHANDLERS
  468. EOF
  469.     }
  470.     else {
  471.         print Q<<EOF;
  472. #    ]]
  473. EOF
  474.     }
  475.     if (/^\s*CASE\s*:/) {
  476.         unshift(@line, $_);
  477.     }
  478.     }
  479.  
  480.     print Q<<EOF if $except;
  481. #    if (errbuf[0])
  482. #    croak(errbuf);
  483. EOF
  484.  
  485.     print Q<<EOF unless $PPCODE;
  486. #    XSRETURN(1);
  487. EOF
  488.  
  489.     print Q<<EOF;
  490. #]]
  491. #
  492. EOF
  493. }
  494.  
  495. # print initialization routine
  496. print qq/extern "C"\n/ if $cplusplus;
  497. print Q<<"EOF";
  498. #XS(boot_$Module_cname)
  499. #[[
  500. #    dXSARGS;
  501. #    char* file = __FILE__;
  502. #
  503. EOF
  504.  
  505. for (@Func_name) {
  506.     $pname = shift(@Func_pname);
  507.     print "    newXS(\"$pname\", XS_$_, file);\n";
  508. }
  509.  
  510. if (@BootCode)
  511. {
  512.     print "\n    /* Initialisation Section */\n\n" ;
  513.     print grep (s/$/\n/, @BootCode) ;
  514.     print "    /* End of Initialisation Section */\n\n" ;
  515. }
  516.  
  517. print "    ST(0) = &sv_yes;\n";
  518. print "    XSRETURN(1);\n";
  519. print "}\n";
  520.  
  521. sub output_init {
  522.     local($type, $num, $init) = @_;
  523.     local($arg) = "ST(" . ($num - 1) . ")";
  524.  
  525.     eval qq/print " $init\\\n"/;
  526. }
  527.  
  528. sub blurt { warn @_; $errors++ }
  529.  
  530. sub generate_init {
  531.     local($type, $num, $var) = @_;
  532.     local($arg) = "ST(" . ($num - 1) . ")";
  533.     local($argoff) = $num - 1;
  534.     local($ntype);
  535.     local($tk);
  536.  
  537.     blurt("'$type' not in typemap"), return unless defined($type_kind{$type});
  538.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  539.     $subtype = $ntype;
  540.     $subtype =~ s/Ptr$//;
  541.     $subtype =~ s/Array$//;
  542.     $tk = $type_kind{$type};
  543.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  544.     $type =~ s/:/_/g;
  545.     $expr = $input_expr{$tk};
  546.     if ($expr =~ /DO_ARRAY_ELEM/) {
  547.     $subexpr = $input_expr{$type_kind{$subtype}};
  548.     $subexpr =~ s/ntype/subtype/g;
  549.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  550.     $subexpr =~ s/\n\t/\n\t\t/g;
  551.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  552.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  553.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  554.     }
  555.     if (defined($defaults{$var})) {
  556.         $expr =~ s/(\t+)/$1    /g;
  557.         $expr =~ s/        /\t/g;
  558.         eval qq/print "\\t$var;\\n"/;
  559.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  560.     } elsif ($expr !~ /^\t\$var =/) {
  561.         eval qq/print "\\t$var;\\n"/;
  562.         $deferred .= eval qq/"\\n$expr;\\n"/;
  563.     } else {
  564.         eval qq/print "$expr;\\n"/;
  565.     }
  566. }
  567.  
  568. sub generate_output {
  569.     local($type, $num, $var) = @_;
  570.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  571.     local($argoff) = $num - 1;
  572.     local($ntype);
  573.  
  574.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  575.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  576.     } else {
  577.         blurt("'$type' not in typemap"), return
  578.         unless defined($type_kind{$type});
  579.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  580.         $ntype =~ s/\(\)//g;
  581.         $subtype = $ntype;
  582.         $subtype =~ s/Ptr$//;
  583.         $subtype =~ s/Array$//;
  584.         $expr = $output_expr{$type_kind{$type}};
  585.         if ($expr =~ /DO_ARRAY_ELEM/) {
  586.         $subexpr = $output_expr{$type_kind{$subtype}};
  587.         $subexpr =~ s/ntype/subtype/g;
  588.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  589.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  590.         $subexpr =~ s/\n\t/\n\t\t/g;
  591.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  592.         eval "print qq\a$expr\a";
  593.         }
  594.         elsif ($var eq 'RETVAL') {
  595.         if ($expr =~ /^\t\$arg = /) {
  596.             eval "print qq\a$expr\a";
  597.             print "\tsv_2mortal(ST(0));\n";
  598.         }
  599.         else {
  600.             print "\tST(0) = sv_newmortal();\n";
  601.             eval "print qq\a$expr\a";
  602.         }
  603.         }
  604.         elsif ($arg =~ /^ST\(\d+\)$/) {
  605.         eval "print qq\a$expr\a";
  606.         }
  607.         elsif ($arg =~ /^ST\(\d+\)$/) {
  608.         eval "print qq\a$expr\a";
  609.         }
  610.         elsif ($arg =~ /^ST\(\d+\)$/) {
  611.         eval "print qq\a$expr\a";
  612.         }
  613.     }
  614. }
  615.  
  616. sub map_type {
  617.     local($type) = @_;
  618.  
  619.     $type =~ s/:/_/g;
  620.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  621.         return "$1 *";
  622.     } else {
  623.         return $type;
  624.     }
  625. }
  626.  
  627. # If this is VMS, the exit status has meaning to the shell, so we
  628. # use a predictable value (SS$_Abort) rather than an arbitrary
  629. # number.
  630. exit $Is_VMS ? 44 : $errors;
  631.